{ SmtpMailSS.pas  SMTP interface component

 	Copyright (C) 2003 - 20xx Stephan Stapel
        (stephan.stapel@web.de)

  This file is part of gnupgcomponents, ocx package.

  GnuPGEngine and GnuPGPublickeyring is free software;
  you can redistribute it and/or
  modify it under the terms of the GNU Lesser General Public
  License as published by the Free Software Foundation; either
  version 2.1 of the License, or (at your option) any later version.

  This library is distributed in the hope that it will be useful,
  but WITHOUT ANY WARRANTY; without even the implied warranty of
  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  Lesser General Public License for more details.

  You should have received a copy of the GNU Lesser General Public
  License along with this library; if not, write to the Free Software
  Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307  USA
}

unit SmtpMailSS;

interface

uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs, NMsmtp, Logging;


const modePlain = 0;
const modeHTML  = 1;


type
  TSmtpMailSS = class(TWinControl)
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
    procedure NMSMTP1AttachmentNotFound(Filename: String);
    procedure NMSMTP1AuthenticationFailed(var Handled: Boolean);
    procedure NMSMTP1Connect(Sender: TObject);
    procedure NMSMTP1ConnectionFailed(Sender: TObject);
    procedure NMSMTP1ConnectionRequired(var Handled: Boolean);
    procedure NMSMTP1Disconnect(Sender: TObject);
    procedure NMSMTP1EncodeEnd(Filename: String);
    procedure NMSMTP1EncodeStart(Filename: String);
    procedure NMSMTP1Failure(Sender: TObject);
    procedure NMSMTP1HeaderIncomplete(var handled: Boolean;
         hiType: Integer);
    procedure NMSMTP1HostResolved(Sender: TComponent);
    procedure NMSMTP1InvalidHost(var Handled: Boolean);
    procedure NMSMTP1MailListReturn(MailAddress: String);
    procedure NMSMTP1PacketSent(Sender: TObject);
    procedure NMSMTP1RecipientNotFound(Recipient: String);
    procedure NMSMTP1SendStart(Sender: TObject);
    procedure NMSMTP1Status(Sender: TComponent; Status: String);
    procedure NMSMTP1Success(Sender: TObject);

    function EncodeString(Decoded : String) : String;
    function EncodeBASE64(Encoded: TMemoryStream ; Decoded: TMemoryStream): Integer;

  private
    Lines: TStringlist;
    Attachments: TStringlist;
    CCRecipients: TStringlist;
    BCCRecipients: TStringList;
    Host: String;
    Port: String;
    Subject: String;
    FromAdress: String;
    FromName: String;
    ToAdress: String;
    UserID: String;
    Password: String;
    Logging: TLogging;
    IsDebugging: Boolean;
    Success: Integer;
    _LastError: String;
    SubType: Integer;
    IsAuthSmtp: Boolean;

    smtp: TNMSMTP;

    procedure DebugMessage(aMessage: String);
  protected
  public
    procedure NewMessage(aFromAdress: String; aSubject: String);
    procedure AddLine(aLine: String);
    function Send: Boolean;
    procedure SetToAdress(aToAdress: String);
    procedure SetFromAdress(aFromAdress: String);
    procedure SetSubject(aSubject: String);
    procedure AddAttachment(anAttachment: String);
    procedure AddCCRecipients(aCCRecipient: String);
    procedure AddBCCRecipients(aBCCRecipient: String);
    procedure SetHost(aHost: String);
    procedure SetUserID(anUserID: String);
    procedure SetPassword(aPassword: String);
    procedure ClearAttachments;
    procedure ClearLines;
    procedure ClearAllRecipients;
    function LastError: String;
    function WasSuccessful: Boolean;
    procedure SetDebugMode;
    procedure SetWorkMode;
    procedure SetSubType(aSubType: Integer);

    procedure SetSmtpAuth;
    procedure SetStandardSmtp;
  published
    { Published-Deklarationen }
  end;

procedure Register;


implementation

procedure Register;
begin
  RegisterComponents('Beispiele', [TSmtpMailSS]);
end;


constructor TSmtpMailSS.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);

  // create the sub objects and initialize certain fields
  Lines:=TStringlist.Create;
  Lines.Clear;
  Attachments:=TStringlist.Create;
  Attachments.Clear;
  CCRecipients:=TStringlist.Create;
  CCRecipients.Clear;
  BCCRecipients:=TStringList.Create;
  BCCRecipients.Clear;
  Host       := '';
  Port       := '25';
  Subject    := '';
  FromAdress := '';
  FromName   := '';  
  UserId     := '';
  Password   := '';
  IsAuthSmtp := false;
end;


destructor TSmtpMailSS.Destroy;
begin
  // delete the sub objects initialized in the constructor
  Lines.Free;
  Attachments.Free;
  CCRecipients.Free;
  BCCRecipients.Free;

  inherited Destroy;
end;


procedure TSmtpMailSS.NewMessage;
begin
  // create a new message
  // check if all sub objects have been initialized
  // (just to be sure) and store the parameter values given when
  // calling this function within local member variables
  if Lines<>nil then Lines.Free;
  Lines:=TStringlist.Create;
  Lines.Clear;

  if Attachments<>nil then Attachments.Free;
  Attachments:=TStringlist.Create;
  Attachments.Clear;

  if CCRecipients<>nil then CCRecipients.Free;
  CCRecipients:=TStringlist.Create;
  CCRecipients.Clear;

  if BCCRecipients<>nil then BCCRecipients.Free;
  BCCRecipients:=TStringList.Create;
  BCCRecipients.Clear;

  SubType := modePlain;
  Host:='';
  Port:='25';
  IsDebugging:=FALSE;

  FromName:=aFromAdress;
  Subject:=aSubject;
end;


function TSmtpMailSS.Send;
begin
  // hope the best (that the sending process will succeed)
  success:=1;
  _LastError:='';

  // create the logging object
  // (needed for debugging purposes)
  Logging:=TLogging.Create;
  Logging.SetFileSuffix('smtp');
  Logging.SetDirectory('c:\temp');

  // check if all values have been previously set
  // if not, jump out
  result:=FALSE;
  if Length(host)=0 then exit;
//  if Length(FromAdress)=0 then exit;
//  if Length(ToAdress)=0 then exit;
  if Lines.Count<1 then exit;

  // create the smtp object, data type is the TNMSTP
  // component class which ships with Delphi
  smtp:=TNMSMTP.Create(self);

  smtp.OnAttachmentNotFound   := NMSMTP1AttachmentNotFound;
  smtp.OnAuthenticationFailed := NMSMTP1AuthenticationFailed;
  smtp.OnConnect              := NMSMTP1Connect;
  smtp.OnConnectionFailed     := NMSMTP1ConnectionFailed;
  smtp.OnConnectionRequired   := NMSMTP1ConnectionRequired;
  smtp.OnDisconnect           := NMSMTP1Disconnect;
  smtp.OnEncodeEnd            := NMSMTP1EncodeEnd;
  smtp.OnEncodeStart          := NMSMTP1EncodeStart;
  smtp.OnFailure              := NMSMTP1Failure;
  smtp.OnHeaderIncomplete     := NMSMTP1HeaderIncomplete;
  smtp.OnHostResolved         := NMSMTP1HostResolved;
  smtp.OnInvalidHost          := NMSMTP1InvalidHost;
  smtp.OnMailListReturn       := NMSMTP1MailListReturn;
  smtp.OnPacketSent           := NMSMTP1PacketSent;
  smtp.OnRecipientNotFound    := NMSMTP1RecipientNotFound;
  smtp.OnSendStart            := NMSMTP1SendStart;
  smtp.OnStatus               := NMSMTP1Status;
  smtp.OnSuccess              := NMSMTP1Success;
  result:=TRUE;

  if (SubType = 1) then
    smtp.SubType := mtHtml
  else
    smtp.SubType := mtPlain;

  smtp.host:=host;

  // set the various fields of the component
  smtp.PostMessage.Attachments.Clear;
  if Attachments<>nil then
    if Attachments.Count>0 then
      smtp.PostMessage.Attachments.Assign(Attachments);

  DebugMessage('After setting attachment value');

  smtp.PostMessage.FromAddress:=FromAdress;
//  DebugMessage('FromAdress:'+FromAdress);
  smtp.PostMessage.FromName := FromName;
//  DebugMessage('FromName:'+FromName);
  smtp.PostMessage.ToAddress.Clear;
  smtp.PostMessage.ToAddress.Add(ToAdress);
//  DebugMessage('ToAdress:'+ToAdress);
  smtp.PostMessage.Subject:=Subject;
//  DebugMessage('Subject:'+Subject);
  smtp.UserID:=UserID;

  smtp.PostMessage.ToCarbonCopy:=TStringList.Create;
  smtp.PostMessage.ToCarbonCopy.Assign(CCRecipients);
  smtp.PostMessage.ToBlindCarbonCopy:=TStringList.Create;
  smtp.PostMessage.ToBlindCarbonCopy.Assign(BCCRecipients);


  // set the mail body
  smtp.PostMessage.Body.Clear;
  if Lines<>nil then
    if Lines.Count>0 then
      smtp.PostMessage.Body.Assign(Lines);


  // start the send process
  if smtp.Connected then
    smtp.Disconnect;
  smtp.Connect;

  // verify address
  if (smtp.verify(ToAdress) = true) then begin
    DebugMessage('recipient address successfully verified.');
  end
  else begin
    DebugMessage('recipient address incorrect.');
  end;

  DebugMessage('smtp object connect');
  smtp.SendMail;
  DebugMessage('stmp object sendMail');
  smtp.Disconnect;
  DebugMessage('smtp object disconnect');
  smtp.Free;
  DebugMessage('smtp object destroyed');

  // delete the sub objects previously initialized
  if Logging<>nil then
    Logging.Free;
end;


function TSmtpMailSS.LastError: String;
begin
  // for error checking within Navision Financials
  result:=_LastError;
end;


function TSmtpMailSS.WasSuccessful: Boolean;
begin
  // for error checking within Navision Financials
  if success=0 then result:=FALSE
    else result:=TRUE;
end;


procedure TSmtpMailSS.DebugMessage(aMessage: String);
begin
  // function which writes certain entries into a
  // logging file which is creating by the
  // Logging-object. This is done only if the component
  // is in debug mode
  if not IsDebugging then exit;

  if Logging=nil then begin
    Logging:=TLogging.Create;
    Logging.SetFileSuffix('smtp');
    Logging.SetDirectory('c:\temp');
  end;
  Logging.AddMessage(aMessage);
end;


procedure TSmtpMailSS.SetDebugMode;
begin
  // activate debug mode
  IsDebugging:=TRUE;
end;


procedure TSmtpMailSS.SetWorkMode;
begin
  // deactive debug mode
  IsDebugging:=FALSE;
end;


// ----------------------------------------------------
// ------------- Property methods ---------------------
procedure TSmtpMailSS.SetToAdress(aToAdress: String);
begin
  ToAdress:=aToAdress;
end;


procedure TSmtpMailSS.SetFromAdress(aFromAdress: String);
begin
  FromAdress:=aFromAdress;
end;


procedure TSmtpMailSS.SetSubject(aSubject: String);
begin
  Subject:=aSubject;
end;


procedure TSmtpMailSS.AddAttachment;
begin
  if Attachments=nil then Attachments:=TStringlist.Create;
  Attachments.Append(anAttachment);
end;


procedure TSmtpMailSS.ClearAttachments;
begin
  Attachments.Clear;
end;


procedure TSmtpMailSS.ClearLines;
begin
  Lines.Clear;
end;



procedure TSmtpMailSS.ClearAllRecipients;
begin
  CCRecipients.Clear;
  BCCRecipients.Clear;
  ToAdress := '';
end;



procedure TSmtpMailSS.SetHost(aHost: String);
begin
  Host:=aHost;
end;


procedure TSmtpMailSS.AddCCRecipients(aCCRecipient: String);
begin
  if CCRecipients=nil then CCRecipients:=TStringlist.Create;
  CCRecipients.Append(aCCRecipient);
end;



procedure TSmtpMailSS.AddBCCRecipients(aBCCRecipient: String);
begin
  if BCCRecipients=nil then BCCRecipients:=TStringlist.Create;
  BCCRecipients.Append(aBCCRecipient);
end;


procedure TSmtpMailSS.SetUserID(anUserID: String);
begin
  UserID:=anUserID;
end;


procedure TSmtpMailSS.SetPassword(aPassword: String);
begin
  Password := aPassword;
end;


procedure TSmtpMailSS.AddLine;
begin
  if Lines=nil then Lines:=TStringlist.Create;
  Lines.Add(aLine);
end;


procedure TSmtpMailSS.SetSubType(aSubType: Integer);
begin
  if (aSubType = 1) then begin
     // HTML-Modus
     SubType := 1;
  end
  else begin
     // Plain-Modus
     SubType := 0;
  end;
end;


procedure TSmtpMailSS.SetSmtpAuth;
begin
  isAuthSmtp := true;
end;


procedure TSmtpMailSS.SetStandardSmtp;
begin
  isAuthSmtp := false;
end;





// --------------------------------------------------------------
// --------------- to maintain control of the sub component state
// --------------------------------------------------------------
procedure TSmtpMailSS.NMSMTP1HostResolved(Sender: TComponent);
begin
  DebugMessage('SMTP Host Resolved');
end;

procedure TSmtpMailSS.NMSMTP1InvalidHost(var Handled: Boolean);
begin
  DebugMessage('SMTP Invalid Host');
  _LastError:='SMTP Invalid Host';
  success:=0;
end;

procedure TSmtpMailSS.NMSMTP1MailListReturn(MailAddress: String);
begin
  DebugMessage('SMTP MailList Return. Mail address: ' + MailAddress);
  _LastError:='SMTP MailList Return';
end;

procedure TSmtpMailSS.NMSMTP1PacketSent(Sender: TObject);
begin
  DebugMessage('SMTP Packet Sent');
end;

procedure TSmtpMailSS.NMSMTP1RecipientNotFound(Recipient: String);
begin
  DebugMessage('SMTP Recipient Not Found. Recipient was: ' + Recipient);
  _LastError:='SMTP Recipient Not Found';
  success:=0;
end;

procedure TSmtpMailSS.NMSMTP1SendStart(Sender: TObject);
begin
  DebugMessage('SMTP Send Start');
end;

procedure TSmtpMailSS.NMSMTP1Status(Sender: TComponent; Status: String);
begin
  DebugMessage('SMTP Status. Status is: ' + Status);
end;

procedure TSmtpMailSS.NMSMTP1Success(Sender: TObject);
begin
  DebugMessage('SMTP Success');
  success:=1;
end;

procedure TSmtpMailSS.NMSMTP1HeaderIncomplete(var handled: Boolean;
  hiType: Integer);
begin
  DebugMessage('SMTP Header Incomplete');
  _LastError:='SMTP Header Incomplete';
  success := 0;
end;

procedure TSmtpMailSS.NMSMTP1Failure(Sender: TObject);
begin
  DebugMessage('SMTP Failure');
  _LastError:='SMTP Failure';
  success := 0;
end;

procedure TSmtpMailSS.NMSMTP1EncodeStart(Filename: String);
begin
  DebugMessage('SMTP Encode Start. Filename: ' + Filename);
end;

procedure TSmtpMailSS.NMSMTP1EncodeEnd(Filename: String);
begin
  DebugMessage('SMTP Encode End. Filename: ' + Filename);
end;

procedure TSmtpMailSS.NMSMTP1ConnectionRequired(var Handled: Boolean);
begin
  DebugMessage('SMTP Connection Required');
  success := 0;
  _LastError:='SMTP Connection Required';
end;



procedure TSmtpMailSS.NMSMTP1Disconnect(Sender: TObject);
begin
  DebugMessage('SMTP Disconnect');
end;



procedure TSmtpMailSS.NMSMTP1ConnectionFailed(Sender: TObject);
begin
  DebugMessage('SMTP Connection Failed');
  _LastError:='SMTP Connection Failed';
  success := 0;
end;



procedure TSmtpMailSS.NMSMTP1Connect(Sender: TObject);
var strUserName, strPassword : String;
    answer: String;
begin
  DebugMessage('SMTP Connect');
  if IsAuthSmtp then begin
    strUserName := EncodeString(UserID);
    strPassword := EncodeString(Password);

//    answer := smtp.Transaction('EHLO');
    answer := smtp.Transaction('AUTH LOGIN');
    answer := smtp.Transaction(strUserName);
    answer := smtp.Transaction(strPassword);
  end;
end;



procedure TSmtpMailSS.NMSMTP1AuthenticationFailed(var Handled: Boolean);
begin
  DebugMessage('SMTP Authentication Failed');
  _LastError:='SMTP Authentication Failed';
  success := 0;
end;

procedure TSmtpMailSS.NMSMTP1AttachmentNotFound(Filename: String);
begin
  DebugMessage('SMTP Attachment Not Found');
  _LastError:='SMTP Attachment Not Found';
  success := 0;
end;



function TSmtpMailSS.EncodeString(Decoded : String) : String;
var mmTemp,mmDecoded:TMemoryStream;
    strTemp:TStrings;
begin
    mmTemp := TMemoryStream.Create;
    mmDecoded:=TMemoryStream.Create;
    strTemp:=TStringList.Create;
    strTemp.Add(Decoded);
    strTemp.SaveToStream(mmTemp);
    mmTemp.Position := 0;

    mmDecoded.CopyFrom(mmTemp,mmTemp.Size-2);

    EncodeBASE64(mmTemp,mmDecoded);

    mmTemp.Position:=0;
    strTemp.LoadFromStream(mmTemp);


    Result:=strTemp[0];
end;


function TSmtpMailSS.EncodeBASE64(Encoded: TMemoryStream ; Decoded: TMemoryStream): Integer;
const
    _Code64: String[64] =
        ('ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+/');
var
    I: LongInt;
    B: array[0..2279] of Byte;
    J, K, L, M, Quads: Integer;
    Stream: string[76];
    EncLine: String;
begin
    Encoded.Clear;
    Stream := '';
    Quads := 0;

    J := Decoded.Size div 2280;
    Decoded.Position := 0;

    for I := 1 to J do
    begin
        Decoded.Read(B, 2280);
        for M := 0 to 39 do
        begin
            for K := 0 to 18 do
            begin
                L:= 57*M + 3*K;
                Stream[Quads+1] := _Code64[(B[L] div 4)+1];
                Stream[Quads+2] := _Code64[(B[L] mod 4)*16 + (B[L+1] div 16)+1];
                Stream[Quads+3] := _Code64[(B[L+1] mod 16)*4 + (B[L+2] div 64)+1];
                Stream[Quads+4] := _Code64[B[L+2] mod 64+1];
                Inc(Quads, 4);
                if Quads = 76 then
                begin
                    Stream[0] := #76;
                    EncLine := Stream+#13#10;
                    Encoded.Write(EncLine[1], Length(EncLine));
                    Quads := 0;
                end;
            end;
        end;
    end;

    J := (Decoded.Size mod 2280) div 3;
    for I := 1 to J do
    begin
        Decoded.Read(B, 3);
        Stream[Quads+1] := _Code64[(B[0] div 4)+1];
        Stream[Quads+2] := _Code64[(B[0] mod 4)*16 + (B[1] div 16)+1];
        Stream[Quads+3] := _Code64[(B[1] mod 16)*4 + (B[2] div 64)+1];
        Stream[Quads+4] := _Code64[B[2] mod 64+1];
        Inc(Quads, 4);

        if Quads = 76 then
        begin
            Stream[0] := #76;
            EncLine := Stream+#13#10;
            Encoded.Write(EncLine[1], Length(EncLine));
            Quads := 0;
        end;
    end;

    if (Decoded.Size mod 3) = 2 then
    begin
        Decoded.Read(B, 2);
        Stream[Quads+1] := _Code64[(B[0] div 4)+1];
        Stream[Quads+2] := _Code64[(B[0] mod 4)*16 + (B[1] div 16)+1];
        Stream[Quads+3] := _Code64[(B[1] mod 16)*4 + 1];
        Stream[Quads+4] := '=';
        Inc(Quads, 4);
    end;

    if (Decoded.Size mod 3) = 1 then
    begin
        Decoded.Read(B, 1);
        Stream[Quads+1] := _Code64[(B[0] div 4)+1];
        Stream[Quads+2] := _Code64[(B[0] mod 4)*16 + 1];
        Stream[Quads+3] := '=';
        Stream[Quads+4] := '=';
        Inc(Quads, 4);
    end;

    Stream[0] := Chr(Quads);
    if Quads > 0 then
    begin
        EncLine := Stream+#13#10;
        Encoded.Write(EncLine[1], Length(EncLine));
    end;

    Result := Encoded.Size;
end;






end.
